Shareware Grab Bag/Shareware Grab Bag.iso/010/cardgame.arc/KLONDIKE.BAS

BASIC Source File | 1986-04-16 | 14KB | 366 lines

10 CLS
15 DIM DECK$(52),PRE(52),SUIT$(4),CARD$(13),CLR(4,2),ROW$(7,19,2),NDECK$(52)
20 DIM ACES$(4)
25 DEF FNR(X)=INT((RND*X)+1)
26 RANDOMIZE(VAL(RIGHT$(TIME$,2)))
30 PRINT "Klondike Solitaire":PRINT
31 PRINT "Do you want color? ";
32 A$=INKEY$:IF A$="" THEN 32
33 GOSUB 10000:IF A$<>"Y" AND A$<>"N" THEN 32 ELSE PRINT A$:COL$=A$
34 PRINT "Do you need Instructions? ";
35 A$=INKEY$:IF A$="" THEN 35
36 GOSUB 10000:IF A$<>"Y" AND A$<>"N" THEN 35 ELSE PRINT A$
37 IF A$="Y" THEN GOSUB 5000
40 PRINT "Initializing ... "
45 GOSUB 1000
50 PRINT "Shuffling ... "
60 GOSUB 1200
65 PRINT "Dealing ... "
70 GOSUB 1500
80 GOSUB 1700
90 TOP=3
91 COLOR 7,1:LOCATE 15,50:PRINT " C - more cards              ";
92 LOCATE 16,50:PRINT " D - move from deck          ";
93 LOCATE 17,50:PRINT " Row Number to move from row ";
94 LOCATE 18,50:PRINT " Q to quit                   ";:COLOR 7,0
100 LOCATE 19,1:PRINT "Next card in deck:";
110 IF NDECK<1 THEN PRINT "None";:GOTO 140
120 C$=NDECK$(TOP):GOSUB 1300
140 LOCATE 21,1:PRINT USING "Card ## of ## left in deck";TOP;NDECK;
150 LOCATE 23,1:PRINT "                               ";
152 IF SCORE > 51 THEN 900
155 LOCATE 22,1:PRINT "What do you want to do?   ";:LOCATE 22,23
160 A$=INKEY$:IF A$="" THEN 160 ELSE GOSUB 10000
170 IF A$="C" THEN PRINT A$;:GOSUB 300:GOTO 100
180 IF A$="D" THEN PRINT A$;:GOSUB 350:GOTO 100
190 IF A$>="1" AND A$<="7" THEN PRINT A$;:GOSUB 600:GOTO 100
200 IF A$="Q" THEN 900
210 GOTO 160
300 REM Get more cards from deck
310 IF TOP=NDECK THEN TOP=3 ELSE TOP=TOP+3
320 IF TOP>NDECK THEN TOP=NDECK
330 RETURN
350 REM Move from deck to a row
360 LOCATE 23,1:PRINT "From deck to row? ";
380 A$=INKEY$:GOSUB 10000:IF (A$>="1" AND A$<="7") OR A$="A" THEN 390 ELSE 380
390 IF A$="A" THEN PRINT "Aces"; ELSE PRINT A$;
395 IF A$="A" THEN 540
400 TOROW=VAL(A$)
410 FOR PLACE=19 TO 1 STEP -1
420 IF ROW$(TOROW,PLACE,2)<>"   " THEN 460
430 NEXT PLACE
432 IF ROW$(TOROW,1,2)="   " AND LEFT$(NDECK$(TOP),2)=" K" THEN PLACE=0:GOTO 500
440 GOSUB 990
450 RETURN
460 BELOW$=ROW$(TOROW,PLACE,2)
470 ABOVE$=NDECK$(TOP)
480 GOSUB 2000       'check if match
490 IF OK$="NO" THEN 440
500 ROW$(TOROW,PLACE+1,1)=NDECK$(TOP)
510 ROW$(TOROW,PLACE+1,2)=NDECK$(TOP)
520 ROW=TOROW:GOSUB 3100
525 GOSUB 2200        'repack deck
530 RETURN
540 REM Play Deck to Aces
550 ABOVE$=NDECK$(TOP)
560 GOSUB 2300        'play to aces
570 IF OK$="NO" THEN 440
580 GOTO 525
600 REM Move from one row to another
610 FROMROW=VAL(A$)
620 FOR FROMPLACE=1 TO 19
630 IF ROW$(FROMROW,FROMPLACE,2)<>DOWN$ THEN 660
640 NEXT FROMPLACE
650 GOSUB 990:RETURN
660 LOCATE 23,1:PRINT "From row";FROMROW;"to row? ";
680 A$=INKEY$:GOSUB 10000:IF (A$>="1" AND A$<="7") OR A$="A" THEN 690 ELSE 680
690 IF A$="A" THEN PRINT "Aces"; ELSE PRINT A$;
695 IF A$="A" THEN 830
700 TOROW=VAL(A$)
710 FOR TOPLACE=19 TO 1 STEP -1
720 IF ROW$(TOROW,TOPLACE,2)<>"   " THEN 760
730 NEXT TOPLACE
732 IF ROW$(TOROW,1,2)="   " AND LEFT$(ROW$(FROMROW,FROMPLACE,2),2)=" K" THEN TOPLACE=0:GOTO 800
740 GOSUB 990
750 RETURN
760 REM
770 ABOVE$=ROW$(FROMROW,FROMPLACE,2)
775 BELOW$=ROW$(TOROW,TOPLACE,2)
780 GOSUB 2000               'check if match
790 IF OK$="NO" THEN 740
800 GOSUB 3200               'move the stack
810 ROW=FROMROW:GOSUB 3100   'redraw a row
815 ROW=TOROW:GOSUB 3100     'redraw a row
820 RETURN
830 REM play from a row to aces
832 FOR FROMPLACE=19 TO 1 STEP -1
834 IF ROW$(FROMROW,FROMPLACE,2)<>"   " THEN 840
836 NEXT FROMPLACE
838 GOSUB 990:RETURN
840 ABOVE$=ROW$(FROMROW,FROMPLACE,2)
850 GOSUB 2300        'play to aces
851 IF OK$="NO" THEN 740
853 REM ROW$(FROMROW,FROMPLACE,1)="   "
854 ROW$(FROMROW,FROMPLACE,2)="   "
855 IF FROMPLACE>1 THEN ROW$(FROMROW,FROMPLACE-1,2)=ROW$(FROMROW,FROMPLACE-1,1)
856 ROW=FROMROW:GOSUB 3100   'redraw a row
860 RETURN
900 REM Exit game
901 LOCATE 19,1:PRINT "                                ";
902 LOCATE 21,1:PRINT "                                ";
903 LOCATE 22,1:PRINT "                                ";
904 LOCATE 23,1:PRINT "                                ";
905 LOCATE 24,1:PRINT "                                ";
910 GOSUB 1800
920 GOSUB 1900
925 FOR I=1 TO 20:A$=INKEY$:NEXT I
930 GOSUB 3400:PRINT "Play again? (Y or N) ";
940 A$=INKEY$:IF A$="" THEN 940
950 GOSUB 10000
960 IF A$="N" THEN 970
961 IF A$="Y" THEN CLS:PRINT "Re-";:GOTO 40
965 GO TO 940
970 CLS:PRINT "Bye":END
990 REM Bad Play
992 COLOR 0,7:LOCATE 23,50:PRINT " Can't do that!            ";
994 LOCATE 24,50:PRINT " Press any key to continue ";:COLOR 7,0
996 IF INKEY$="" THEN 996
997 LOCATE 23,50:PRINT "                            ";
998 LOCATE 24,50:PRINT "                            ";
999 RETURN
1000 REM
1005 DOWN$=CHR$(178):DOWN$=DOWN$+DOWN$+DOWN$
1009 IF COL$="N" THEN 1020
1010 FOR I=1 TO 2:CLR(I,1)=4:CLR(I,2)=7:NEXT
1015 FOR I=3 TO 4:CLR(I,1)=0:CLR(I,2)=7:NEXT
1019 GO TO 1030
1020 FOR I=1 TO 2:CLR(I,1)=0:CLR(I,2)=7:NEXT
1025 FOR I=3 TO 4:CLR(I,1)=7:CLR(I,2)=0:NEXT
1030 FOR I=1 TO 4:SUIT$(I)=CHR$(I+2):NEXT I
1035 FOR I=1 TO 4:ACES$(I)="   ":NEXT I
1040 FOR I=2 TO 9:CARD$(I)=STR$(I):NEXT I
1050 CARD$(1)=" A":CARD$(10)="10":CARD$(11)=" J":CARD$(12)=" Q":CARD$(13)=" K"
1060 FOR I=1 TO 4
1070 FOR J=1 TO 13
1080 K=(I-1)*13+J
1090 DECK$(K)=CARD$(J)+SUIT$(I)
1100 NEXT J
1110 NEXT I
1120 FOR I=1 TO 7
1130 FOR J=1 TO 19
1140 ROW$(I,J,1)="   ":ROW$(I,J,2)="   "
1150 NEXT J,I
1160 SCORE=0
1170 RETURN
1200 REM Shuffle
1210 FOR I=1 TO 52:NDECK$(I)="":NEXT I
1220 FOR I=1 TO 52
1230 R=FNR(52)
1240 IF NDECK$(R)="" THEN NDECK$(R)=DECK$(I) ELSE 1230
1250 NEXT I
1260 FOR I=1 TO 52
1270 DECK$(I)=NDECK$(I)
1280 NEXT I
1290 RETURN
1300 REM Display a card (C$)
1310 IF C$=DOWN$ THEN 1350
1320 IF C$="   " THEN 1350
1330 S=ASC(RIGHT$(C$,1))-2
1340 COLOR CLR(S,1),CLR(S,2)
1350 PRINT C$;:COLOR 7,0:PRINT "    ";
1360 RETURN
1500 REM Deal the game
1510 C=1
1520 FOR PLACE=1 TO 7
1530 FOR ROW=1 TO 7
1535 IF ROW<PLACE THEN ROW$(ROW,PLACE,1)="   ":ROW$(ROW,PLACE,2)="   ":GOTO 1570
1540 ROW$(ROW,PLACE,1)=DECK$(C)
1550 C=C+1
1560 IF ROW=PLACE THEN ROW$(ROW,PLACE,2)=ROW$(ROW,PLACE,1) ELSE ROW$(ROW,PLACE,2)=DOWN$
1570 NEXT ROW,PLACE
1580 CLS
1590 L=10:LOCATE 1,5:PRINT "Aces:"
1600 REM FOR ACE=1 TO 4
1610 REM LOCATE 1,L:COLOR 0,7:PRINT "  ";SUIT$(ACE);:COLOR 7,0
1620 REM L=L+10
1630 REM NEXT ACE
1640 LOCATE 4,1
1645 PRINT " 1      2      3      4      5      6      7"
1650 FOR PLACE=1 TO 7
1660 FOR ROW=1 TO 7
1661 C$=ROW$(ROW,PLACE,2)
1665 C$=ROW$(ROW,PLACE,2)
1670 GOSUB 1300
1680 NEXT ROW:PRINT:NEXT PLACE
1690 RETURN
1700 REM Prepare to play
1710 FOR I=1 TO 24
1715 J=I+28
1720 NDECK$(I)=DECK$(J)
1730 NEXT I
1740 FOR I=25 TO 52
1750 NDECK$(I)=""
1760 NEXT I
1770 NDECK=24
1780 RETURN
1800 REM Show Deck
1810 LL=3
1815 LOCATE 3,50:PRINT "Cards left in deck:";
1817 IF NDECK=0 THEN 1890
1820 FOR I=1 TO NDECK STEP 3
1830 LL=LL+1:LOCATE LL,50
1840 FOR J=0 TO 2
1845 IF I+J>NDECK THEN 1870
1850 C$=NDECK$(I+J)
1860 GOSUB 1300
1870 NEXT J:PRINT "     ";:NEXT I
1880 RETURN
1890 LOCATE 4,50:PRINT "None.                     ";
1895 FOR I=2 TO 3:LOCATE LL+I,50:PRINT "                          ";:NEXT
1899 RETURN
1900 REM show cards
1910 LL=4:COUNT=0
1920 FOR PLACE=1 TO 19
1925 LL=LL+1:LOCATE LL,1
1930 FOR ROW=1 TO 7
1935 C$=ROW$(ROW,PLACE,2)
1940 IF C$=DOWN$ THEN C$=ROW$(ROW,PLACE,1):COUNT=COUNT+1
1950 GOSUB 1300
1960 NEXT ROW
1965 IF COUNT=0 THEN PLACE=20
1970 LOCATE LL,1:COUNT=0
1980 NEXT PLACE
1990 RETURN
2000 REM Check if above$ can go on below$
2010 IN$=ABOVE$:GOSUB 3000:ANUM=NUM:ASUIT=SUIT
2020 IN$=BELOW$:GOSUB 3000:BNUM=NUM:BSUIT=SUIT
2030 OK$="YES"
2040 IF ANUM+1<>BNUM THEN OK$="NO"
2050 IF ASUIT<=2 AND BSUIT<=2 THEN OK$="NO"
2060 IF ASUIT>=3 AND BSUIT>=3 THEN OK$="NO"
2070 RETURN
2200 REM Repack Deck
2205 IF NDECK=1 THEN TOP=0:NDECK=0:RETURN
2210 FOR I=TOP+1 TO NDECK
2220 NDECK$(I-1)=NDECK$(I)
2230 NEXT I
2240 NDECK=NDECK-1
2250 TOP=TOP-1
2260 IF TOP<1 THEN TOP=3
2280 IF TOP>NDECK THEN TOP=NDECK
2290 RETURN
2300 REM Play ABOVE$ to aces
2310 IN$=ABOVE$:GOSUB 3000:ANUM=NUM:ASUIT=SUIT
2315 IN$=ACES$(ASUIT):IF IN$="   " THEN BNUM=0:GOTO 2330
2320 GOSUB 3000:BNUM=NUM
2330 IF ANUM=BNUM+1 THEN OK$="YES" ELSE OK$="NO":RETURN
2340 ACES$(ASUIT)=ABOVE$
2350 LOCATE 1,ASUIT*10:C$=ABOVE$
2360 GOSUB 1300
2365 SCORE=SCORE+1:LOCATE 1,50:PRINT "Score";SCORE
2370 RETURN
3000 REM change in$ to num and suit
3005 IF A$="   " THEN NUM=0:SUIT=0:RETURN
3010 A$=LEFT$(IN$,2)
3020 IF A$=" A" THEN A$=" 1"
3030 IF A$=" J" THEN A$="11"
3040 IF A$=" Q" THEN A$="12"
3050 IF A$=" K" THEN A$="13"
3060 NUM=VAL(A$)
3070 SUIT=ASC(RIGHT$(IN$,1))-2
3080 RETURN
3100 REM Redraw a row
3110 R=((ROW-1)*7)+1
3130 FOR PLACE=1 TO 19
3140 IF ROW$(ROW,PLACE,1)="   " THEN PLACE=20:GOTO 3180
3150 LOCATE 4+PLACE,R
3160 C$=ROW$(ROW,PLACE,2)
3170 GOSUB 1300
3180 NEXT PLACE
3190 RETURN
3200 REM Copy part of a row
3205 FP=FROMPLACE:TP=TOPLACE
3207 IF TP=1 AND LEFT$(ROW$(FROMROW,FROMPLACE,2),2)=" K" THEN 3220
3210 TP=TP+1
3220 ROW$(TOROW,TP,1)=ROW$(FROMROW,FP,1)
3225 ROW$(TOROW,TP,2)=ROW$(FROMROW,FP,2)
3230 REM ROW$(FROMROW,FP,1)="   "
3235 ROW$(FROMROW,FP,2)="   "
3240 FP=FP+1
3250 IF ROW$(FROMROW,FP,2)<>"   " THEN 3210
3260 IF FROMPLACE>1 THEN 3300
3270 ROW$(FROMROW,FP,1)="   "
3280 ROW$(FROMROW,1,2)="   "
3290 RETURN
3300 ROW$(FROMROW,FROMPLACE-1,2)=ROW$(FROMROW,FROMPLACE-1,1)
3310 RETURN
3400 REM Evaluate game performance
3405 LOCATE 19,1:PRINT "You placed";SCORE;"cards on the Aces piles"
3410 SC=INT(SCORE/10)+1
3415 IF SCORE=52 THEN SC=7
3420 IF SCORE=0 THEN GOSUB 3520:RETURN
3430 ON SC GOSUB 3450,3460, 3470, 3480, 3490, 3500, 3510
3440 RETURN  'score 0-9  10-19 20-29 30-39 40-49 50+
3450 PRINT "Too bad, better try again!":RETURN
3460 PRINT "Not too bad, still a lot of room for improvement":RETURN
3470 PRINT "Pretty good, keep trying.":RETURN
3480 PRINT "Good job.  Keep up the good work!":RETURN
3490 PRINT "Very good.  Now you have the idea!":RETURN
3500 PRINT "Almost got it.  Bad break!":RETURN
3510 PRINT "YOU DID IT!!  Congratulations!":RETURN
3520 PRINT "Oops!  You must have had a bad shuffle!":RETURN
5000 REM Instructions
5010 cls:PRINT "Klondike Solitaire"
5020 PRINT
5030 PRINT "This program plays a solitaire game.  A deck of 52 cards is"
5040 PRINT "used and 28 cards are dealt into 7 rows (piles).  The first"
5050 PRINT "row at the left has one card, the second two, and so on, up"
5060 PRINT "to seven in the last row.  The last card of each row is face"
5070 PRINT "up and all the rest are face down.  On each row you may"
5080 PRINT "build in descending sequence: red on black, such as the ten"
5090 PRINT "of hearts on the jack of clubs or spades.":PRINT
5100 PRINT "You can move the face up cards in a row as a unit.  The top"
5110 PRINT "card being moved must fit in sequence and color with the"
5120 PRINT "card being moved under in the other row.  When you uncover a"
5130 PRINT "face-down card on a row, it will be turned up.":PRINT
5140 PRINT "You are always entitled to have 7 rows, and if one is"
5150 PRINT "entirely open you may put a king in the space.  Whenever you"
5160 PRINT "free an ace, move it too the ace foundations.  On the aces"
5170 PRINT "you may build up in suit and sequence and then to win the"
5180 PRINT "game, you have to build each suit up to a king.  A card must"
5190 PRINT "be the top card of a row to be played from, to the rows onto"
5200 PRINT "the ace foundations.  Once played on the ace foundations, a"
5210 PRINT "card can NOT be removed to help elsewhere."
5220 PRINT "     ** Press any key to continue **";
5230 IF INKEY$="" THEN 5230 ELSE CLS
5240 PRINT "The remaining 24 cards in the deck are used as the stock."
5250 PRINT "Every third card may be turned up and the deck may be gone"
5260 PRINT "through any number of times.  The top card is available for"
5270 PRINT "play to any row or the ace foundations.  When the top card"
5280 PRINT "is played, the next card will then be available.":PRINT
5290 PRINT "You win if you can build all 4 ace foundations up to kings."
5300 PRINT "You lose when you can not make any further plays from the"
5310 PRINT "deck, or rows.":PRINT
5320 PRINT "Plays are controlled by keyboard commands as follows:":PRINT
5330 PRINT "D = Play top card of the Deck to aces (A) or row (#1-7)."
5340 PRINT "    Answer 'A' or row number 1-7 to next question to"
5350 PRINT "    indicate where the card is to be moved."
5360 PRINT "C = Get next Card in the deck and wait for next play command."
5370 PRINT "Q = Quit game and turn over all face-down cards."
5380 PRINT "#1-7 = Play cards from row# to Aces (A) or another row (#1-7)"
5390 PRINT
5400 PRINT "An error message will be displayed if an invalid response is"
5410 PRINT "given to any question or any invalid plays attempted."
5420 PRINT:PRINT "     ** Press any key to continue **";
5430 IF INKEY$="" THEN 5430 ELSE CLS:RETURN
10000 REM Shift A$ to upper case
10020 L=LEN(A$)                          'get length of a$
10030 FOR I=1 TO L                       'look at each char
10040 TEST=ASC(MID$(A$,I,1))             'get acsii value
10050 IF TEST<97 OR TEST>122 THEN 10080  'skip if not lower case
10060 TEST=TEST-32                       'bump down to upper case
10070 MID$(A$,I,1)=CHR$(TEST)            'insert upper case back
10080 NEXT I                             'move on to next char
10090 RETURN